Public Sub ImportADOXML(strXMLFileName As String, strTableName As String)

    'Import an ADO-formatted XML file into a table with a specified name

    Dim rst1 As ADODB.Recordset

    Dim rst2 As ADODB.Recordset

    Dim cat1 As ADOX.Catalog

    Dim tbl1 As ADOX.Table

    Dim col1 As ADOX.Column

    Dim fld1 As ADODB.Field

    

    On Error GoTo ErrorHandler

    

    Set cat1 = New ADOX.Catalog

    Set cat1.ActiveConnection = CurrentProject.Connection

    

    'Create ADO recordset from XML file

    Set rst1 = New ADODB.Recordset

    rst1.Open strXMLFileName, , , , adCmdFile

        

    'Create new table

    Set tbl1 = New ADOX.Table

    tbl1.Name = strTableName

    

    'Create table's columns

    For Each fld1 In rst1.Fields

        Set col1 = New ADOX.Column

        col1.Name = fld1.Name

        col1.Type = fld1.Type

        col1.DefinedSize = fld1.DefinedSize

        tbl1.Columns.Append col1

    Next fld1

    

    'Save the new table

    cat1.Tables.Append tbl1

    

    'Open a recordset on the new table

    Set rst2 = New ADODB.Recordset

    rst2.Open strTableName, CurrentProject.Connection, _

            adOpenKeyset, adLockOptimistic

            

    'Transfer records from recordset to new table

    Do Until rst1.EOF

        rst2.AddNew

            For Each fld1 In rst1.Fields

                rst2(fld1.Name) = rst1(fld1.Name)

            Next fld1

        rst2.Update

        rst1.MoveNext

    Loop

    

    'Clean up after yourself

    rst1.Close

    Set rst1 = Nothing

    rst2.Close

    Set rst2 = Nothing

    Set col1 = Nothing

    Set tbl1 = Nothing

    Set cat1 = Nothing

    

    'Display the new table

    Application.RefreshDatabaseWindow

    

ExitRoutine:

    Exit Sub

    

ErrorHandler:

    MsgBox Err.Number & ": " & Err.Description, vbCritical, _

        "ImportADOXML"

    Resume ExitRoutine

    

End Sub

